home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / c / catch.c < prev    next >
Encoding:
C/C++ Source or Header  |  1987-06-04  |  2.6 KB  |  145 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.  
  9.     catch.c
  10.  
  11.     dynamic non-local exit
  12. */
  13.  
  14. #include "include.h"
  15.  
  16. Fcatch(args)
  17. object args;
  18. {
  19.     object *top = vs_top;
  20.     object tag;
  21.  
  22.     if (endp(args))
  23.         FEtoo_few_argumentsF(args);
  24.     eval(MMcar(args));
  25.     vs_top = top;
  26.     vs_push(vs_base[0]);
  27.     frs_push(FRS_CATCH, vs_base[0]);
  28.     if (nlj_active)
  29.         nlj_active = FALSE;
  30.     else
  31.         Fprogn(MMcdr(args));
  32.     frs_pop();
  33. }
  34.  
  35. siLerror_set()
  36. {
  37.     object *old_base = vs_base;
  38.     object *value_top;
  39.     object *old_lex = lex_env;
  40.  
  41.     check_arg(1);
  42.     vs_push(Cnil);
  43.     frs_push(FRS_CATCHALL, Cnil);
  44.     if (nlj_active) {
  45.         nlj_active = FALSE;
  46.         old_base[0] = nlj_tag;
  47.         frs_pop();
  48.         vs_base = old_base;
  49.         vs_top = vs_base+1;
  50.         lex_env = old_lex;
  51.         return;
  52.     } else {
  53.         lex_env = vs_top;
  54.         vs_push(Cnil);
  55.         vs_push(Cnil);
  56.         vs_push(Cnil);
  57.         eval(vs_base[0]);
  58.         old_base[0] = Cnil;
  59.     }
  60.     frs_pop();
  61.     lex_env = old_lex;
  62.     value_top = vs_top;
  63.     vs_top = old_base + 1;
  64.     while(vs_base<value_top) {
  65.         vs_push(vs_base[0]);
  66.         vs_base++;
  67.     }
  68.     vs_base = old_base;
  69. }
  70.  
  71. Funwind_protect(args)
  72. object args;
  73. {
  74.     object *top = vs_top;
  75.     object *value_top;
  76.     if (endp(args))
  77.         FEtoo_few_argumentsF(args);
  78.     frs_push(FRS_PROTECT, Cnil);
  79.     if (nlj_active) {
  80.         object tag = nlj_tag;
  81.         frame_ptr fr = nlj_fr;
  82.         object *base;
  83.  
  84.         value_top = vs_top;
  85.         vs_top = top;
  86.         while(vs_base<value_top) {
  87.              vs_push(vs_base[0]);
  88.             vs_base++;
  89.         }
  90.         value_top = vs_top;
  91.         nlj_active = FALSE;
  92.         frs_pop();
  93.         Fprogn(MMcdr(args));
  94.         vs_base = top;
  95.         vs_top = value_top;
  96.         if (vs_top == vs_base) vs_base[0] = Cnil;
  97.         unwind(fr, tag);
  98.         /* never reached */
  99.     } else {
  100.         eval(MMcar(args));
  101.         frs_pop();
  102.         value_top = vs_top;
  103.         vs_top = top;
  104.         while(vs_base<value_top) {
  105.              vs_push(vs_base[0]);
  106.             vs_base++;
  107.         }
  108.         value_top = vs_top;
  109.         Fprogn(MMcdr(args));
  110.         vs_base = top;
  111.         vs_top = value_top;
  112.         if (vs_top == vs_base) vs_base[0] = Cnil;
  113.     }
  114. }
  115.  
  116. Fthrow(args)
  117. object args;
  118. {
  119.     object *top = vs_top;
  120.     object tag;
  121.     frame_ptr fr;
  122.     if (endp(args) || endp(MMcdr(args)))
  123.         FEtoo_few_argumentsF(args);
  124.     if (!endp(MMcddr(args)))
  125.         FEtoo_many_argumentsF(args);
  126.     eval(MMcar(args));
  127.     vs_top = top;
  128.     tag = vs_base[0];
  129.     vs_push(tag);
  130.     fr = frs_sch_catch(tag);
  131.     if (fr == NULL)
  132.         FEerror("~S is an undefined tag.", 1, tag);
  133.     eval(MMcadr(args));
  134.     unwind(fr, tag);
  135.     /* never reached */
  136. }
  137.  
  138. init_catch()
  139. {
  140.     make_special_form("CATCH", Fcatch);
  141.     make_si_function("ERROR-SET", siLerror_set);
  142.     make_special_form("UNWIND-PROTECT", Funwind_protect);
  143.     make_special_form("THROW", Fthrow);
  144. }
  145.